home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / EDWIN / LISP.S < prev    next >
Encoding:
Text File  |  1993-06-15  |  8.4 KB  |  259 lines
  1. ;;;
  2. ;;;    Copyright (c) 1985 Massachusetts Institute of Technology
  3. ;;;
  4. ;;;    This material was developed by the Scheme project at the
  5. ;;;    Massachusetts Institute of Technology, Department of
  6. ;;;    Electrical Engineering and Computer Science.  Permission to
  7. ;;;    copy this software, to redistribute it, and to use it for any
  8. ;;;    purpose is granted, subject to the following restrictions and
  9. ;;;    understandings.
  10. ;;;
  11. ;;;    1. Any copy made of this software must include this copyright
  12. ;;;    notice in full.
  13. ;;;
  14. ;;;    2. Users of this software agree to make their best efforts (a)
  15. ;;;    to return to the MIT Scheme project any improvements or
  16. ;;;    extensions that they make, so that these may be included in
  17. ;;;    future releases; and (b) to inform MIT of noteworthy uses of
  18. ;;;    this software.
  19. ;;;
  20. ;;;    3.  All materials developed as a consequence of the use of
  21. ;;;    this software shall duly acknowledge such use, in accordance
  22. ;;;    with the usual standards of acknowledging credit in academic
  23. ;;;    research.
  24. ;;;
  25. ;;;    4. MIT has made no warrantee or representation that the
  26. ;;;    operation of this software will be error-free, and MIT is
  27. ;;;    under no obligation to provide any services, by way of
  28. ;;;    maintenance, update, or otherwise.
  29. ;;;
  30. ;;;    5.  In conjunction with products arising from the use of this
  31. ;;;    material, there shall be no use of the name of the
  32. ;;;    Massachusetts Institute of Technology nor of any adaptation
  33. ;;;    thereof in any advertising, promotional, or sales literature
  34. ;;;    without prior written consent from MIT in each case.
  35. ;;;
  36. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  37. ;;;
  38. ;;;     Modified by Texas Instruments Inc 8/15/85
  39. ;;;
  40. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  41.  
  42. ;;; moving forward
  43.  
  44. (define (forward-one-list start end)
  45.   (forward-sexp:top start end 0))
  46.  
  47. (define (forward-down-one-list start end)
  48.   (forward-sexp:top start end -1))
  49.  
  50. (define (forward-up-one-list start end)
  51.   (forward-sexp:top start end 1))
  52.  
  53. (define forward-sexp:top
  54.   (lambda (start end depth)
  55.     (letrec
  56.       ((forward-sexp:top
  57.          (lambda (start end depth)
  58.        (and (mark< start end)
  59.         (search-forward start end depth))))
  60.  
  61.        (search-forward
  62.     (lambda (start end depth)
  63.       (let ((mark (find-next-char-in-set start end sexp-delims)))
  64.         (and mark
  65.          (cond
  66.           ((char=? (mark-right-char mark)   ;;; (
  67.                #\) )
  68.                    (list-forward-close (mark1+ mark #F) end depth))
  69.                   (else (list-forward-open (mark1+ mark #F)
  70.                                            end depth)))))))
  71.  
  72.       (list-forward-open
  73.         (lambda (start end depth)
  74.       (if (= depth -1)
  75.           start
  76.           (forward-sexp:top start end (1+ depth)))))
  77.  
  78.       (list-forward-close
  79.         (lambda (start end depth)
  80.       (and (> depth 0)
  81.            (if (= depth 1)
  82.            start
  83.            (forward-sexp:top start end (-1+ depth)))))))
  84.     (forward-sexp:top start end depth))))
  85.  
  86.  
  87. ;;; sexp movement
  88.  
  89. (define (forward-one-sexp start end )
  90.     (let ((m (find-next-char-in-set start end char-set:not-whitespace)))
  91.       (if m
  92.           (let ((char (mark-right-char m)))
  93.             (cond ((char=? char #\( )         ;;; )
  94.                    (forward-one-list m end))
  95.                   ((char-set-sexp? char)
  96.                    (find-next-char-in-set m end sexp-delimeter-chars))
  97.                   ((char=? char #\")      ;;;"
  98.                    (find-next-closing-quote (mark1+ m #F) end)) ;;;)
  99.                   ((char=? char #\)) (mark1+ m #F))   ;;; (
  100.                   ((or (char=? char #\') (char=? char #\`))
  101.                    (forward-one-sexp (mark1+ m #F) end))
  102.                   (else (find-next-char-in-set m end char-set:whitespace))))
  103.           #F)))
  104.  
  105. (define (backward-one-sexp start end )
  106.     (let ((m (find-previous-char-in-set start end char-set:not-whitespace)))
  107.       (if m
  108.           (let ((char (mark-left-char m)))
  109.             (cond ((char=? char #\) )         ;;; (
  110.                    (backward-one-list m end))
  111.                   ((char-set-sexp? char)
  112.                    (find-previous-char-in-set m end sexp-delimeter-chars))
  113.                   ((char=? char #\")      ;;;"
  114.                    (find-previous-closing-quote (mark-1+ m #F) end)) ;;;)
  115.                   ((char=? char #\()     ;;;)
  116.                    (mark-1+ m #F))
  117.                   ((or (char=? char #\') (char=? char #\`))
  118.                    (backward-one-sexp (mark-1+ m #F) end))
  119.                   (else (find-previous-char-in-set m end
  120.                                                    char-set:whitespace))))
  121.           #F)))
  122.  
  123. (define find-next-closing-quote
  124.   (lambda (start end)
  125.     (let ((m (find-next-char-in-set start end string-quote)))
  126.       (and m
  127.           (mark1+ m #F)))))
  128.  
  129. (define find-previous-closing-quote
  130.   (lambda (start end)
  131.     (let ((m (find-previous-char-in-set start end string-quote)))
  132.       (and m
  133.           (mark-1+ m #F)))))
  134.  
  135. (define string-quote (make-string 1 #\"))
  136.  
  137.  
  138. ;;; moving backward
  139.  
  140. (define (backward-down-one-list start end)
  141.   (backward-sexp:top start end -1))
  142.  
  143. (define (backward-up-one-list start end)
  144.   (backward-sexp:top start end 1))
  145.  
  146. (define forward-list)
  147. (define backward-list)
  148. (make-motion-pair forward-one-list backward-one-list
  149.   (lambda (f b)
  150.     (set! forward-list f)
  151.     (set! backward-list b)))
  152.  
  153. (define forward-down-list)
  154. (define backward-down-list)
  155. (make-motion-pair forward-down-one-list backward-down-one-list
  156.   (lambda (f b)
  157.     (set! forward-down-list f)
  158.     (set! backward-down-list b)))
  159.  
  160. (define forward-up-list)
  161. (define backward-up-list)
  162. (make-motion-pair forward-up-one-list backward-up-one-list
  163.   (lambda (f b)
  164.     (set! forward-up-list f)
  165.     (set! backward-up-list b)))
  166.  
  167. ;;;
  168.  
  169. (define forward-sexp '())
  170. (define backward-sexp '())
  171.  
  172. (make-motion-pair forward-one-sexp backward-one-sexp
  173.   (lambda (f b)
  174.     (set! forward-sexp f)
  175.     (set! backward-sexp b)))
  176.  
  177.  
  178.  
  179. ;;; Lisp Indenting
  180.  
  181. (define scheme:delim (char-set-union char-set:whitespace sexp-delims))
  182.  
  183. (define lisp-indent-line
  184.   (lambda (point)
  185.     (letrec
  186.       ((calculate-lisp-indent
  187.          (lambda (mark)
  188.        (let ((containing-sexp
  189.            (backward-up-one-list mark (group-start mark))))
  190.          (if containing-sexp
  191.          (let ((next-sexp-start
  192.             (find-next-char-in-set
  193.                               (mark1+ containing-sexp #F) mark
  194.                            char-set:not-whitespace)))
  195.            (if next-sexp-start
  196.                (if (char-ci=? #\( (mark-right-char next-sexp-start));)
  197.                (mark-column next-sexp-start)
  198.                (let ((next-sexp-end
  199.                   (find-next-char-in-set next-sexp-start mark
  200.                              scheme:delim)))
  201.                  (table-lookup containing-sexp next-sexp-start
  202.                        next-sexp-end mark)))
  203.                (1+ (mark-column containing-sexp))))
  204.          0))))
  205.  
  206.        (table-lookup
  207.          (lambda (containing-sexp sexp-start sexp-end limit-mark)
  208.        (let ((string (substring (line-string (mark-line sexp-start))
  209.                     (mark-position sexp-start)
  210.                     (mark-position sexp-end))))
  211.          (cond ((is-string-member? string %standard-funcs)
  212.             (+ lisp-indent (mark-column containing-sexp)))
  213.            (else (let ((m (find-next-char-in-set sexp-end limit-mark
  214.                          char-set:not-whitespace)))
  215.                (if (and m
  216.                                     (not (char=? (mark-right-char m) #\;)))
  217.                    (mark-column m)
  218.                    (+ lisp-indent
  219.                   (mark-column containing-sexp)))))))))
  220.  
  221.      (is-string-member?
  222.             (lambda (string list1)
  223.               (if list1
  224.                   (if (string-ci=? string (car list1))
  225.                       #T
  226.                       (is-string-member? string (cdr list1)))
  227.                   #F))))
  228.  
  229.        (let* ((start-mark (line-start point 0 #F))
  230.           (start (horizontal-space-end (line-start point 0 #F))))
  231.      (let ((indentation (calculate-lisp-indent start)))
  232.            (if (<> indentation (mark-column start))
  233.                (begin
  234.         (region-delete! (make-region start-mark start))
  235.         (insert-chars #\space indentation start-mark))))))))
  236.  
  237. (define %standard-funcs
  238.   '("define" "lambda" "let" "letrec" "let*" "fluid-let" "macro" "rec" "named-lambda" "call/cc" "case" "with-input-from-file" "call-with-input-file"))
  239.  
  240.  
  241.  
  242.  
  243. (define lisp-indent-sexp
  244.   (lambda (point)
  245.     (letrec
  246.       ((end (line-start (forward-sexp point 1 'ERROR) 0 #F))
  247.        (loop
  248.     (lambda (start)
  249.       (lisp-indent-line start)
  250.       (if (not (mark= start end))
  251.           (loop (line-start start 1 #F))))))
  252.       (if (mark< point end)
  253.       (loop (line-start point 1 #F))))))
  254.  
  255.  
  256.  
  257.  
  258.  
  259.